home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / lisp / stk-3.002 / stk-3 / STk-3.1 / Lib / ftp.stk < prev    next >
Encoding:
Text File  |  1996-07-19  |  5.4 KB  |  172 lines
  1. ;;;;
  2. ;;;; f t p  . s t k        -- A very incomplete library for ftping file
  3. ;;;;                   Error are not (yet) properly detected
  4. ;;;;                   A lot of things are missing
  5. ;;;;                   (See RFC 959)
  6. ;;;;
  7. ;;;; Copyright ⌐ 1996 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
  8. ;;;; 
  9. ;;;; Permission to use, copy, and/or distribute this software and its
  10. ;;;; documentation for any purpose and without fee is hereby granted, provided
  11. ;;;; that both the above copyright notice and this permission notice appear in
  12. ;;;; all copies and derived works.  Fees for distribution or use of this
  13. ;;;; software or derived works may only be charged with express written
  14. ;;;; permission of the copyright holder.  
  15. ;;;; This software is provided ``as is'' without express or implied warranty.
  16. ;;;;
  17. ;;;;           Author: Erick Gallesio [eg@unice.fr]
  18. ;;;;    Creation date: 10-Jun-1996 12:22
  19. ;;;; Last file update: 19-Jul-1996 10:30
  20.  
  21. (require "stklos")
  22. (require "posix")
  23.  
  24. (define-class <FTP-connection> ()
  25.   ((port   :init-keyword :port :accessor port :initform 21)
  26.    (host   :init-keyword :host :accessor host)
  27.    (echo   :init-keyword :echo :initform display)
  28.    (socket :accessor socket-of)))
  29.  
  30. ;;;;
  31. ;;;; Initialize (make the connection)
  32. ;;;;
  33. (define-method initialize ((self <FTP-connection>) initargs)
  34.   (next-method)
  35.   (let ((port (slot-ref self 'port))
  36.     (host (slot-ref self 'host)))
  37.     (slot-set! self 'socket (make-client-socket host port))
  38.     (ftp-read-line  self #f)))
  39.  
  40. ;;;;
  41. ;;;; ftp-read-line
  42. ;;;;
  43. (define-method ftp-read-line ((self <FTP-connection>) echo?)
  44.   (let ((in           (socket-input (socket-of self)))
  45.     (analyse-code (lambda (code) (< code 400))))
  46.  
  47.     (let loop ((srch #f) ; the code we search for multi-line responses
  48.            (l    (read-line in)))
  49.       (if (eof-object? l)
  50.       (begin
  51.         (error "PANIC: ~A\n. Closing connection." msg)
  52.         (socket-shutdown (socket-of self)))
  53.       (let ((code (string->number (substring l 0 3)))
  54.         (sep  (string-ref l 3))
  55.         (msg  (substring  l 4 (string-length l))))
  56.         (when echo?
  57.           ((slot-ref self 'echo) (string-append msg "\n")))
  58.         (if srch
  59.         ;; We are already in a multi-line sequence 
  60.         (if (and (eq? code srch) (eq? sep #\space))
  61.             (analyse-code code)
  62.             (loop srch (read-line in)))
  63.         (if (char=? sep #\-)
  64.             ;; We start a multi-line sequence
  65.             (loop code (read-line in))
  66.             (analyse-code code))))))))
  67.  
  68. ;;;;
  69. ;;;; ftp-write-line
  70. ;;;;
  71. (define-method ftp-write-line ((self <FTP-connection>) l echo?)
  72.   (let ((out (socket-output (socket-of self))))
  73.     (display l out) (newline out) (flush out)
  74.     (ftp-read-line self echo?)))
  75.  
  76. ;;;
  77. ;;; Utilities
  78. ;;;
  79. (define-method  ftp-data ((self <FTP-connection>) cmd)
  80.   (let* ((s  (make-server-socket 0))
  81.      (c  (socket-of self))
  82.      (n  (socket-port-number s))
  83.      (ip (regexp-replace-all "\\." (socket-local-address c) ",")))
  84.  
  85.     (if (and (ftp-write-line self (format #f "PORT ~A,~A,~A" ip
  86.                       (quotient n 256) (remainder n 256)) #f)
  87.          (ftp-write-line self cmd #f))
  88.     ;; Transfer seems OK
  89.     (begin
  90.       (socket-accept-connection s)
  91.       (let ((in (socket-input s)))
  92.         (do ((l (read-line in) (read-line in)))
  93.         ((eof-object? l))
  94.           (display l)
  95.           (newline)))
  96.       (ftp-read-line self #f))
  97.     ;; There something which is not OK (we should be more precise here)
  98.     #f)))
  99.  
  100. (define-method ftp-data ((self <FTP-connection>) cmd)
  101.   (let* ((s  (make-server-socket 0))
  102.      (c  (socket-of self))
  103.      (n  (socket-port-number s))
  104.      (ip (regexp-replace-all "\\." (socket-local-address c) ",")))
  105.     (and (ftp-write-line self (format #f "PORT ~A,~A,~A" ip
  106.                       (quotient n 256) (remainder n 256)) #f)
  107.      (ftp-write-line self cmd #f)
  108.      (socket-accept-connection s)
  109.      s)))
  110.  
  111. (define-method ftp-copy ((self <FTP-connection>) from to nowait?)
  112.   (do ((c (read-char from) (read-char from)))
  113.       ((eof-object? c))
  114.     (write-char c to))
  115.   (flush to)
  116.   (close-input-port from)
  117.   (or nowait? (ftp-read-line self #f)))
  118.  
  119. ;;;;==========================================================================
  120. ;;;;
  121. ;;;; FTP library (only a subpart of a true library)
  122. ;;;;
  123. ;;;;==========================================================================
  124.  
  125. (define (ftp-login s user pass)
  126.   (and (ftp-write-line s (format #f "USER ~A" user) #t)
  127.        (ftp-write-line s (format #f "PASS ~A" pass) #t)))
  128.   
  129. (define (ftp-quit s)
  130.   (ftp-write-line s "QUIT" #t)
  131.   (socket-shutdown (socket-of s)))
  132.  
  133. (define (ftp-chdir s dir)
  134.   (ftp-write-line s (format #f "CWD ~A" dir) #f))
  135.  
  136. (define (ftp-pwd s)
  137.   (ftp-write-line s "PWD" #t))
  138.  
  139. (define (ftp-type s mode)
  140.   (ftp-write-line s (format #f "TYPE ~A" mode) #f))
  141.  
  142. (define (ftp-help s . cmd)
  143.   (ftp-write-line s
  144.      (format #f "HELP~A" (if (null? cmd) "" (string-append " " (car cmd))))
  145.      #t))
  146.  
  147. (define (ftp-dir s . args)
  148.   (ftp-write-line s "TYPE A" #f)
  149.   (let* ((cmd  (if (null? args) "LIST" (format #f "NLST ~A" (car args))))
  150.      (sock (ftp-data s cmd)))
  151.     (and sock (ftp-copy s (socket-input sock) (current-output-port) #f))))
  152.  
  153. (define (ftp-get s file)
  154.   (ftp-write-line s "TYPE I" #f)
  155.   (let* ((cmd (format #f "RETR ~A" file))
  156.      (sock (ftp-data s cmd)))
  157.     (and sock (ftp-copy s (socket-input sock) (open-output-file file) #f))))
  158.  
  159. (define (ftp-display s file)
  160.   (ftp-write-line s "TYPE A" #f)
  161.   (let* ((cmd (format #f "RETR ~A" file))
  162.      (sock (ftp-data s cmd)))
  163.     (and sock (ftp-copy s (socket-input sock) (current-output-port) #f))))
  164.  
  165. (define (ftp-put s file)
  166.   (ftp-write-line s "TYPE I" #f)
  167.   (let* ((cmd (format #f "STOR ~A" file))
  168.      (sock (ftp-data s cmd)))
  169.     (and sock (ftp-copy s (open-input-file file) (socket-output sock) #t))))
  170.  
  171. (provide "ftp")
  172.